home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPSRC.ARC / XLBFUN.C < prev    next >
Text File  |  1986-05-17  |  10KB  |  450 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *xlenv;
  10. extern NODE *s_evalhook,*s_applyhook;
  11. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
  12. extern NODE *s_lambda,*s_macro;
  13. extern NODE *s_comma,*s_comat;
  14. extern NODE *s_unbound;
  15. extern char gsprefix[];
  16. extern int gsnumber;
  17.  
  18. /* external routines */
  19. extern NODE *xlxeval();
  20.  
  21. /* forward declarations */
  22. FORWARD NODE *bquote1();
  23. FORWARD NODE *defun();
  24. FORWARD NODE *makesymbol();
  25.  
  26. /* xeval - the built-in function 'eval' */
  27. NODE *xeval(args)
  28.   NODE *args;
  29. {
  30.     NODE *expr;
  31.  
  32.     /* get the expression to evaluate */
  33.     expr = xlarg(&args);
  34.     xllastarg(args);
  35.  
  36.     /* evaluate the expression */
  37.     return (xleval(expr));
  38. }
  39.  
  40. /* xapply - the built-in function 'apply' */
  41. NODE *xapply(args)
  42.   NODE *args;
  43. {
  44.     NODE ***oldstk,*fun,*arglist,*val;
  45.  
  46.     /* create a new stack frame */
  47.     oldstk = xlstack;
  48.     xlsave1(fun);
  49.  
  50.     /* get the function and argument list */
  51.     fun = xlarg(&args);
  52.     arglist = xlmatch(LIST,&args);
  53.     xllastarg(args);
  54.  
  55.     /* if the function is a symbol, get its value */
  56.     if (symbolp(fun))
  57.     fun = xleval(fun);
  58.  
  59.     /* apply the function to the arguments */
  60.     val = xlapply(fun,arglist);
  61.  
  62.     /* restore the previous stack frame */
  63.     xlstack = oldstk;
  64.  
  65.     /* return the expression evaluated */
  66.     return (val);
  67. }
  68.  
  69. /* xfuncall - the built-in function 'funcall' */
  70. NODE *xfuncall(args)
  71.   NODE *args;
  72. {
  73.     NODE ***oldstk,*fun,*val;
  74.  
  75.     /* create a new stack frame */
  76.     oldstk = xlstack;
  77.     xlsave1(fun);
  78.  
  79.     /* get the function (the rest of the args is the argument list) */
  80.     fun = xlarg(&args);
  81.  
  82.     /* if the function is a symbol, get its value */
  83.     if (symbolp(fun))
  84.     fun = xleval(fun);
  85.  
  86.     /* apply the function to the arguments */
  87.     val = xlapply(fun,args);
  88.  
  89.     /* restore the previous stack frame */
  90.     xlstack = oldstk;
  91.  
  92.     /* return the expression evaluated */
  93.     return (val);
  94. }
  95.  
  96. /* xset - built-in function set */
  97. NODE *xset(args)
  98.   NODE *args;
  99. {
  100.     NODE *sym,*val;
  101.  
  102.     /* get the symbol and new value */
  103.     sym = xlmatch(SYM,&args);
  104.     val = xlarg(&args);
  105.     xllastarg(args);
  106.  
  107.     /* assign the symbol the value of argument 2 and the return value */
  108.     setvalue(sym,val);
  109.  
  110.     /* return the result value */
  111.     return (val);
  112. }
  113.  
  114. /* xgensym - generate a symbol */
  115. NODE *xgensym(args)
  116.   NODE *args;
  117. {
  118.     char sym[STRMAX+1];
  119.     NODE *x;
  120.  
  121.     /* get the prefix or number */
  122.     if (args) {
  123.     x = xlarg(&args);
  124.     switch (ntype(x)) {
  125.     case STR:
  126.         strcpy(gsprefix,getstring(x));
  127.         break;
  128.     case INT:
  129.         gsnumber = getfixnum(x);
  130.         break;
  131.     default:
  132.         xlerror("bad argument type",x);
  133.     }
  134.     }
  135.     xllastarg(args);
  136.  
  137.     /* create the pname of the new symbol */
  138.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  139.  
  140.     /* make a symbol with this print name */
  141.     return (xlmakesym(sym,DYNAMIC));
  142. }
  143.  
  144. /* xmakesymbol - make a new uninterned symbol */
  145. NODE *xmakesymbol(args)
  146.   NODE *args;
  147. {
  148.     return (makesymbol(args,FALSE));
  149. }
  150.  
  151. /* xintern - make a new interned symbol */
  152. NODE *xintern(args)
  153.   NODE *args;
  154. {
  155.     return (makesymbol(args,TRUE));
  156. }
  157.  
  158. /* makesymbol - make a new symbol */
  159. LOCAL NODE *makesymbol(args,iflag)
  160.   NODE *args; int iflag;
  161. {
  162.     char *pname;
  163.  
  164.     /* get the print name of the symbol to intern */
  165.     pname = getstring(xlmatch(STR,&args));
  166.     xllastarg(args);
  167.  
  168.     /* make the symbol */
  169.     return (iflag ? xlenter(pname,DYNAMIC) : xlmakesym(pname,DYNAMIC));
  170. }
  171.  
  172. /* xsymname - get the print name of a symbol */
  173. NODE *xsymname(args)
  174.   NODE *args;
  175. {
  176.     NODE *sym;
  177.  
  178.     /* get the symbol */
  179.     sym = xlmatch(SYM,&args);
  180.     xllastarg(args);
  181.  
  182.     /* return the print name */
  183.     return (getpname(sym));
  184. }
  185.  
  186. /* xsymvalue - get the value of a symbol */
  187. NODE *xsymvalue(args)
  188.   NODE *args;
  189. {
  190.     NODE *sym,*val;
  191.  
  192.     /* get the symbol */
  193.     sym = xlmatch(SYM,&args);
  194.     xllastarg(args);
  195.  
  196.     /* get the global value */
  197.     while ((val = getvalue(sym)) == s_unbound)
  198.     xlcerror("try evaluating symbol again","unbound variable",sym);
  199.  
  200.     /* return its value */
  201.     return (val);
  202. }
  203.  
  204. /* xsymplist - get the property list of a symbol */
  205. NODE *xsymplist(args)
  206.   NODE *args;
  207. {
  208.     NODE *sym;
  209.  
  210.     /* get the symbol */
  211.     sym = xlmatch(SYM,&args);
  212.     xllastarg(args);
  213.  
  214.     /* return the property list */
  215.     return (getplist(sym));
  216. }
  217.  
  218. /* xget - get the value of a property */
  219. NODE *xget(args)
  220.   NODE *args;
  221. {
  222.     NODE *sym,*prp;
  223.  
  224.     /* get the symbol and property */
  225.     sym = xlmatch(SYM,&args);
  226.     prp = xlmatch(SYM,&args);
  227.     xllastarg(args);
  228.  
  229.     /* retrieve the property value */
  230.     return (xlgetprop(sym,prp));
  231. }
  232.  
  233. /* xputprop - set the value of a property */
  234. NODE *xputprop(args)
  235.   NODE *args;
  236. {
  237.     NODE *sym,*val,*prp;
  238.  
  239.     /* get the symbol and property */
  240.     sym = xlmatch(SYM,&args);
  241.     val = xlarg(&args);
  242.     prp = xlmatch(SYM,&args);
  243.     xllastarg(args);
  244.  
  245.     /* set the property value */
  246.     xlputprop(sym,val,prp);
  247.  
  248.     /* return the value */
  249.     return (val);
  250. }
  251.  
  252. /* xremprop - remove a property value from a property list */
  253. NODE *xremprop(args)
  254.   NODE *args;
  255. {
  256.     NODE *sym,*prp;
  257.  
  258.     /* get the symbol and property */
  259.     sym = xlmatch(SYM,&args);
  260.     prp = xlmatch(SYM,&args);
  261.     xllastarg(args);
  262.  
  263.     /* remove the property */
  264.     xlremprop(sym,prp);
  265.  
  266.     /* return nil */
  267.     return (NIL);
  268. }
  269.  
  270. /* xhash - compute the hash value of a string or symbol */
  271. NODE *xhash(args)
  272.   NODE *args;
  273. {
  274.     char *str;
  275.     NODE *val;
  276.     int len;
  277.  
  278.     /* get the string and the table length */
  279.     val = xlarg(&args);
  280.     len = (int)getfixnum(xlmatch(INT,&args));
  281.     xllastarg(args);
  282.  
  283.     /* get the string */
  284.     if (symbolp(val))
  285.     str = getstring(getpname(val));
  286.     else if (stringp(val))
  287.     str = getstring(val);
  288.     else
  289.     xlerror("bad argument type",val);
  290.  
  291.     /* return the hash index */
  292.     return (cvfixnum((FIXNUM)hash(str,len)));
  293. }
  294.  
  295. /* xaref - array reference function */
  296. NODE *xaref(args)
  297.   NODE *args;
  298. {
  299.     NODE *array,*index;
  300.     int i;
  301.  
  302.     /* get the array and the index */
  303.     array = xlmatch(VECT,&args);
  304.     index = xlmatch(INT,&args); i = (int)getfixnum(index);
  305.     xllastarg(args);
  306.  
  307.     /* range check the index */
  308.     if (i < 0 || i >= getsize(array))
  309.     xlerror("array index out of bounds",index);
  310.  
  311.     /* return the array element */
  312.     return (getelement(array,i));
  313. }
  314.  
  315. /* xmkarray - make a new array */
  316. NODE *xmkarray(args)
  317.   NODE *args;
  318. {
  319.     int size;
  320.  
  321.     /* get the size of the array */
  322.     size = (int)getfixnum(xlmatch(INT,&args));
  323.     xllastarg(args);
  324.  
  325.     /* create the array */
  326.     return (newvector(size));
  327. }
  328.  
  329. /* xerror - special form 'error' */
  330. NODE *xerror(args)
  331.   NODE *args;
  332. {
  333.     char *emsg; NODE *arg;
  334.  
  335.     /* get the error message and the argument */
  336.     emsg = getstring(xlmatch(STR,&args));
  337.     arg = (args ? xlarg(&args) : s_unbound);
  338.     xllastarg(args);
  339.  
  340.     /* signal the error */
  341.     xlerror(emsg,arg);
  342. }
  343.  
  344. /* xcerror - special form 'cerror' */
  345. NODE *xcerror(args)
  346.   NODE *args;
  347. {
  348.     char *cmsg,*emsg; NODE *arg;
  349.  
  350.     /* get the correction message, the error message, and the argument */
  351.     cmsg = getstring(xlmatch(STR,&args));
  352.     emsg = getstring(xlmatch(STR,&args));
  353.     arg = (args ? xlarg(&args) : s_unbound);
  354.     xllastarg(args);
  355.  
  356.     /* signal the error */
  357.     xlcerror(cmsg,emsg,arg);
  358.  
  359.     /* return nil */
  360.     return (NIL);
  361. }
  362.  
  363. /* xbreak - special form 'break' */
  364. NODE *xbreak(args)
  365.   NODE *args;
  366. {
  367.     char *emsg; NODE *arg;
  368.  
  369.     /* get the error message */
  370.     emsg = (args ? getstring(xlmatch(STR,&args)) : "**BREAK**");
  371.     arg = (args ? xlarg(&args) : s_unbound);
  372.     xllastarg(args);
  373.  
  374.     /* enter the break loop */
  375.     xlbreak(emsg,arg);
  376.  
  377.     /* return nil */
  378.     return (NIL);
  379. }
  380.  
  381. /* xcleanup - special form 'clean-up' */
  382. NODE *xcleanup(args)
  383.   NODE *args;
  384. {
  385.     xllastarg(args);
  386.     xlcleanup();
  387. }
  388.  
  389. /* xtoplevel - special form 'top-level' */
  390. NODE *xtoplevel(args)
  391.   NODE *args;
  392. {
  393.     xllastarg(args);
  394.     xltoplevel();
  395. }
  396.  
  397. /* xcontinue - special form 'continue' */
  398. NODE *xcontinue(args)
  399.   NODE *args;
  400. {
  401.     xllastarg(args);
  402.     xlcontinue();
  403. }
  404.  
  405. /* xevalhook - eval hook function */
  406. NODE *xevalhook(args)
  407.   NODE *args;
  408. {
  409.     NODE ***oldstk,*expr,*ehook,*ahook,*oldenv;
  410.     NODE *newehook,*newahook,*newenv,*val;
  411.  
  412.     /* create a new stack frame */
  413.     oldstk = xlstack;
  414.     xlstkcheck(4);
  415.     xlsave(ehook);
  416.     xlsave(ahook);
  417.     xlsave(oldenv);
  418.     xlsave(newenv);
  419.  
  420.     /* get the expression, the new hook functions and the environment */
  421.     expr = xlarg(&args);
  422.     newehook = xlarg(&args);
  423.     newahook = xlarg(&args);
  424.     newenv = (args ? xlarg(&args) : xlenv);
  425.     xllastarg(args);
  426.  
  427.     /* bind *evalhook* and *applyhook* to the hook functions */
  428.     ehook = getvalue(s_evalhook);
  429.     setvalue(s_evalhook,newehook);
  430.     ahook = getvalue(s_applyhook);
  431.     setvalue(s_applyhook,newahook);
  432.     oldenv = xlenv;
  433.     xlenv = newenv;
  434.  
  435.     /* evaluate the expression (bypassing *evalhook*) */
  436.     val = xlxeval(expr);
  437.  
  438.     /* unbind the hook variables */
  439.     setvalue(s_evalhook,ehook);
  440.     setvalue(s_applyhook,ahook);
  441.     xlenv = oldenv;
  442.  
  443.     /* restore the previous stack frame */
  444.     xlstack = oldstk;
  445.  
  446.     /* return the result */
  447.     return (val);
  448. }
  449.  
  450.